Problema HEX
(CEOI - Polonia iulie 1997)
Numere hexazecimale

Baza sistemului hexazecimal este 16. Pentru a scrie numerele in acest sistem se
folosesc 16 caractere: 0,1,..,9,A,B,..,F. De exemplu, valoarea numarului CF2 
este  12*16^2+15*16+2=3314 in zecimal. 
Fie X multimea tuturor numerelor intregi pozitive a caror reprezentare hexazecimala 
are cel mult 8 caractere si nu contine nici un caracter de doua ori. Caracterul 
cel mai semnificativ este diferit de zero. 
Cel mai mare element din X este numarul cu reprezentarea hexazecimala FEDCBA98; 
al doilea cel mai mare numar este FEDCBA97, al treilea FEDCBA96 s.a.m.d.

Problema
Scrieti un program care:
- citeste numarul n pozitiv din fisierul text HEX.IN; n nu depaseste numarul de
   elemente ale multimii X;
- afla al n-lea cel mai mare element din X;
- scrie rezultatul in fisierul text HEX.OUT.

Intrare
Prima linie din HEX.IN contine numarul n in reprezentare zecimala. 

Iesire
Pe prima linie a fisierului HEX.OUT se scrie al n-lea cel mai mare element din X 
in reprezentare hexazecimala.

Exemplu
Pentru intrarea:
11
iesirea corecta este:
FEDCBA87

S-au dat 10 teste, fiecare cotat cu cate 3 puncte.
Timp limita per test: 2 sec.
==================================
TESTE INTRARE:
test 0:
11
---------------------
test 1:
2
---------------------
Test 2:
100
---------------
test 3:
1997
---------------------
test 4:
91262317
---------------------
test 5:
486486001
----------------------
test 6:
545911723
---------------------
test 7:
546481140
--------------------
test 8:
546481140
-----------------------
test 9:
18
-----------------------
test 10:
546480803
==========================
TESTE IESIRE:
test 0:
FEDCBA87
----------------------
test 1:
FEDCBA97
----------------------
test 2:
FEDCB98A
-------------------
test 3:
FEDC9B81
----------------------
test 4:
D2C0FB48
-----------------------
test 5:
FEDCBA9
----------------------
test 6:
127B3A
-------------------------
test 7:
183
-----------------------
test 8:
1
----------------------
test 9:
FEDCBA80
-------------------------
test 10:
17F
============================================

Solutia 1 (Angel Proorocu - Ploiesti)
{$A+,B-,D+,E+,F-,G-,I+,L+,N+,O-,P-,Q+,R+,S+,T-,V+,X+}
{$M 65384,0,655360}


program Hexazecimal;

   uses Crt;

   var nr,suma,num,ales:longint;
       i,j:integer;
       f:text;
       lim:array[1..9]of longint;
       puse:array[0..15]of byte;

procedure Afiseaza(k:integer);
   begin
    if k<10 then write(f,k);
    case k of
     10:write(f,'a');
     11:write(f,'b');
     12:write(f,'c');
     13:write(f,'d');
     14:write(f,'e');
     15:write(f,'f');
    end;
   end;

procedure Cauta(max,k:longint);
   var i,ki:integer;
   begin
     if k=9 then exit;

      lim[8]:=max;
{}    for i:=7 downto 1 do lim[i]:=lim[i+1]*(i+lim[8]-8);
{}
     for i:=1 to max do
     if i*lim[k+1]>=nr then break;

    ki:=0;
    for j:=0 to 15 do
     begin
      if puse[j]=0 then inc(ki);
      if ki=i then begin puse[j]:=1; afiseaza(15-j); break; end;
     end;
    nr:=nr-(i-1)*lim[k+1];
    cauta(max-1,k+1);
   end;

procedure ReadData;
   var i,k,apar:integer;
       al:set of byte;
   begin
    assign(f,'hex.in');
    fillchar(puse,sizeof(puse),0);
    reset(f);
    readln(f,nr);
    close(f);

    lim[8]:=16;
    lim[9]:=1;
    for i:=7 downto 1 do lim[i]:=(lim[i+1]*(i+8));
    k:=0;
    for i:=1 to 8 do lim[i]:=lim[i]-lim[i] div 16;
    suma:=0;
    while (suma<nr) do
     begin
      inc(k);
      suma:=suma+lim[k];
     end;
    nr:=nr-(suma-lim[k]);

    assign(f,'hex.out');
    rewrite(f);
    cauta(15,k);
    close(F);
   end;

begin
 ReadData;
end.
---------------------------
Solutia 2 (Bogdan Batog - Bucuresti)
const
    st:string='0123456789ABCDEF';
var
   fil                          :text;
   n                            :comp;
   ar                           :array[0..16,0..16] of comp;
   i,j,f,k                      :integer;
   v                            :array[1..8] of integer;
   u                            :set of byte;

begin
     assign(fil,'HEX.IN');
     reset(fil);
     readln(fil,n);
     close(fil);
     n:=n-1;
     for j:=1 to 16 do
     begin
        AR[j,1]:=j;
          for i:=2 to j do AR[j,i]:=AR[j,i-1]*(j-i+1);
     end;

     k:=8;
     while n>=AR[16,k]-AR[15,k-1] do
     begin
          n:=n-(AR[16,k]-AR[15,k-1]);
          dec(k);
     end;

     for i:=1 to k do v[i]:=15;
     u:=[];
     for i:=1 to k-1 do
     begin
          while v[i] in u do dec(v[i]);
          while n>=AR[16-i,k-i] do
          begin
              Dec(v[i]);
              while v[i] in u do dec(v[i]);
              n:=n-AR[16-i,k-i];
          end;
          u:=u+[v[i]];
     end;
     while v[k] in u do dec(v[k]);
     while n>0 do
     begin
        dec(v[k]);
        while v[k] in u do dec(v[k]);
        n:=n-1;
     end;
     assign(fil,'HEX.OUT');
     rewrite(fil);
     for f:=1 to k do write(fil,st[v[f]+1]);
     writeln(fil);
     close(fil)
end.
----------------------------
Solutia 3 (Adrian Carcu - Bictrita Nasaud)
const hex:array[0..15] of char='0123456789ABCDEF';
var i,j,k,kk,n,p,p1,p2,cat:longint;
    sel:array[0..15] of boolean;
    fis,fis2:text;
    s:string;

function aranj(n,k:byte;var p:longint):longint;
var i:byte;
begin
   p:=1;
   if k>0 then for i:=n-k+1 to n do p:=p*i;
   aranj:=p;
end;

begin
   assign(fis,'hex.in'); reset(fis);
   assign(fis2,'hex.out'); rewrite(fis2);
   for i:=0 to 15 do sel[i]:=false;
   readln(fis,n); dec(n); s[0]:=#8;
   k:=8;
   while n>aranj(16,k,p1)-aranj(15,k-1,p2) do begin
      s[9-k]:='0';
      dec(k); n:=n-(p1-p2);
      end;
   for i:=0 to k-1 do begin
      aranj(15-i,k-i-1,p);
      cat:=n div p; kk:=0;
      for j:=0 to 15 do
         if not sel[j] then begin
            if kk=cat then break;
            inc(kk);
            end;
      s[9-k+i]:=hex[15-j];
      if j<>15 then sel[j]:=true;
      n:=n mod p;
      end;
   while s[1]='0' do s:=copy(s,2,length(s)-1);
   writeln(fis2,s);
   close(fis); close(fis2);
end.
--------------------------------

Solutia 4 (Tudor Leu - Focasni)
const cifra:array[1..16] of char=('0','1','2','3','4','5','6','7','8','9',
                                  'A','B','C','D','E','F');
      ni='hex10.in';
      no='con';
var f:array[1..16] of boolean;
    nr:array[1..8] of char;
    i,j,k,l,m,n,p,q:longint;
begin
     assign(input,ni);reset(input);
     assign(output,no);rewrite(output);
     readln(n);
     k:=210*180*143*90;
     i:=9;j:=0;
     while n>k do begin
        j:=j+1;n:=n-k;k:=k div i;i:=i+1;
     end;
     n:=n;k:=k div 15;
     if j=8 then begin writeln(0);halt end;
     for i:=1 to 16 do f[i]:=false;
     l:=15;
     for i:=1 to 8-j do begin
        m:=1;
        while n>m*k do m:=m+1;
        n:=n-(m-1)*k;
        m:=m;q:=0;p:=16;
        while q<m do begin
             if not f[p] then q:=q+1;
             p:=p-1;
        end;
        p:=p+1;
        f[p]:=true;write(cifra[p]);
        k:=k div l;l:=l-1;
     end;
     writeln
end.
----------------------------

Solutia 5 (Dragos Vingarzan - Medias)
uses crt;
const x:string='FEDCBA9876543210';
var mut,o,i,j,n,m,k,pz,l:longint;
    fi,fo:text;
    s:string;
    a:array [0..9] of integer;
    p:array [1..16] of boolean;
begin
o:=2;
clrscr;
repeat
 n:=o;
 dec(n);
 s:='FEDCBA98';
 if n=0 then begin
              writeln(s);
             end;
 for i:=0 to 8 do
  a[i]:=8+i;
 m:=1;
 pz:=0;
 while n>=m do
  begin
   inc(pz);
   m:=m*a[pz];
  end;
 s:='FEDCBA98';
 if m=n then s:=copy(s,1,8-pz-1)
        else s:=copy(s,1,8-pz);
 a[0]:=1;
 k:=n;
 repeat
  if m=n then mut:=k div (m div a[pz-1])
         else mut:=k div (m div a[pz]);
  for i:=1 to 16 do
   p[i]:=false;
  for i:=1 to length(s) do
   for j:=1 to 16 do
    if x[j]=s[i] then begin
                       p[j]:=true;
                       break;
                      end;
  i:=1;
  while p[i] do inc(i); {am gasit prima lit pe care trebuie s-o pun x[i]}
  for l:=1 to mut do
   begin
    inc(i);
    while p[i] do inc(i);
   end;
  s:=s+x[i];
  m:=m div a[pz];
  k:=k mod m;
  dec(pz);
 until pz<=0;


 gotoxy(1,1);
 writeln(o:15,'->',s);
 readln;
 inc(o);
 until 1=2;
end.
-------------------------------

Solutia 6 (Virgil Serbanuta - Focsani)
const b16:array[0..15] of char=('0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F');
var pa,pa1:array[0..8] of comp;
    n:comp;
    nrc:byte;

procedure initpasi;
var i,j:byte;
    a:comp;
begin
a:=15;
for i:=15 downto 9 do
    a:=a*i;
pa[8]:=a;
pa1[8]:=a;
pa[0]:=1;
pa1[0]:=1;
for i:=1 to 7 do pa1[i]:=pa1[i-1]*(8+i);
for i:=7 downto 1 do
    begin
    a:=15;
    for j:=15 downto 17-i do
        a:=a*j;
    pa[i]:=a;
    end;
end;

procedure getcifre;
var i:byte;
begin
nrc:=8;
while pa[nrc]<n do
      begin
      n:=n-pa[nrc];
      dec(nrc);
      end;
for i:=1 to 7 do pa1[i]:=pa1[i-1]*(16-nrc+i);
end;

procedure calcul;
var mat:array[1..8] of byte;
    s:set of byte;
    i,j:integer;
    x,y:comp;
    ss:string;
begin
s:=[0..15];
for i:=1 to nrc do
    mat[i]:=17-i;
n:=n-1;
for i:=nrc downto 1 do
    begin
    x:=int(n/pa1[i-1]);
    n:=n-pa1[i-1]*x;
    mat[nrc-i+1]:=mat[nrc-i+1]-round(x);
    end;
ss:='';
for i:=nrc downto 1 do
    begin
    j:=-1;
    while mat[nrc-i+1]>0 do
          begin
          inc(j);
          if j in s then dec(mat[nrc-i+1]);
          end;
    s:=s-[j];
    ss:=ss+b16[j];
    end;
writeln(ss);
end;

begin
assign(input,'hex.in');
reset(input);
assign(output,'hex.out');
rewrite(output);
initpasi;
readln(n);
getcifre;
calcul;
end.
------------------------------

Solutia 7 (Cristian cadar - Bucuresti)
uses crt;
var
   n,card:longint;
   f:text;
   st:string;
   s:set of char;
   a:array[1..8] of longint;
   gasit:boolean;

procedure citire;
begin
     clrscr;
     write('Fisier intrare:');
     readln(st);
     assign(f,st);
     reset(f);
     readln(f,n);
     close(f);
end;

function Ar(n,k:longint):longint;
var
   i:integer;
   aux:longint;
begin
     aux:=1;
     for i:=n-k+1 to n do
         aux:=aux*i;
     ar:=aux;
end;

function urm(c:char):char;
begin
     if c in ['B'..'F','1'..'9']
        then
            begin
                 dec(c);
                 urm:=c;
            end
        else
            urm:='9';
end;

function next(c:char):char;
var
   i:char;
begin
     i:=urm(c);
     while i in s do
        i:=urm(i);
     next:=i;
end;

function next1(c:char):char;
var
   i:char;
begin
     i:='F';
     while i in s do
        i:=urm(i);
     next1:=i;
end;

procedure rec(c:char;poz:byte;n:longint);
begin
     if not gasit and (c='0')
        then rec('F',poz-1,n);
     if poz=0
        then
            begin
                 writeln;
                 halt;
            end;
     if n<=ar(16-card-1,poz-1)
        then
            begin
                 gasit:=true;
                 inc(card);
                 write(c);
                 s:=s+[c];
                 rec(next1(c),poz-1,n);
            end
        else rec(next(c),poz,n-ar(16-card-1,poz-1));
end;

procedure prelucrare;
var
   i:byte;
begin
     for i:=1 to 8 do
         a[i]:=ar(16,i);
     card:=0;
     gasit:=false;
     s:=[];
     rec('F',8,n);
end;

begin
     citire;
     prelucrare;
end.
---------------------------------

Solutia 8 (Mihai Stroe - Bucuresti)
{$A+,B-,D+,E+,F-,G-,I+,L+,N+,O-,P-,Q-,R-,S+,T-,V+,X+,Y+}
{$M 65520,0,655360}

const c:string='FEDCBA9876543210';
var i,j,k,l,m,n:longint;
    fi,fo:text;
    fact:array[0..16]of extended;
    a:array[0..16,0..16]of extended;
    lim:array[0..9]of extended;
    xx:array[1..9]of longint;
    numar:array[1..8]of byte;
    s:string;

procedure makenumber;
begin
  for i:=m downto 1 do
      begin
        j:=0;
        while (j+1)*a[i+16-m-1,i-1]<n do inc(j);
        n:=n-trunc(j*a[i+16-m-1,i-1]);
        numar[8-i+1]:=j;
{        inc(numar[8]);}
      end;
  for i:=8-m+1 to 8 do
      begin
        write(fo,c[numar[i]+1]);
        delete(c,numar[i]+1,1);
{        for j:=i+1 to 8 do
            if numar[j]>=numar[i] then
               inc(numar[j]);}
      end;
  writeln(fo);
end;

procedure solve;
begin
  fact[0]:=1;
  for i:=1 to 16 do
      fact[i]:=i*fact[i-1];
  for i:=1 to 16 do
      for j:=1 to i do
          begin
            a[i,j]:=1;
            for k:=i-j+1 to i do
                a[i,j]:=a[i,j]*k;
          end;
  for i:=8 downto 1 do
      lim[i]:=lim[i+1]+a[16,i]-a[16-1,i-1];

  for i:=1 to 8 do
      xx[i]:=trunc(lim[i]);
  m:=8;
  while xx[m]<n do dec(m);
  n:=n-xx[m+1];
  for i:=1 to 16 do
      a[i,0]:=1;
  makenumber;
end;

begin
  readln(s);
  assign(fi,'hex'+s+'.in');
  assign(fo,'');
  reset(fi);
  rewrite(fo);
  readln(fi,n);
  close(fi);
  solve;
  close(fo);
  assign(fi,'hex'+s+'.out');
  reset(fi);
  readln(fi,s);
  writeln(s);
  close(fi);
end.
---------------------------
